{
 *****************************************************************************
 *                                                                           *
 *  This code is taken from LResources.pp, written by Mattias Gaertner       *
 *  and part of the Lazarus Component Library (LCL).                         *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL.txt, included in the Lazarus IDE,      *
 *  for details about the copyright.                                         *
 *                                                                           *
 *  This program is distributed in the hope that it will be useful,          *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 *                                                                           *
 *****************************************************************************


     A lazarus resource is an ansistring, with a name and a valuetype. Both, name
     and valuetype, are ansistrings as well.

     Lazarus resources are normally included via an include directive in the
     initialization part of a unit. To create such include files use the
     utility lazres, to be found in the Tools subfolder of the Lazarus directory.

     The code in this unit allows data such as images or text to be embedded in an
     executable which uses fpgui, without entailing any dependency on the LCL.
 }

unit fpg_resources;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

type

  TfpgResource = class
  public
    Name: AnsiString;
    ValueType: AnsiString;
    Value: AnsiString;
  end;

  { TfpgResourceList }

  TfpgResourceList = class(TObject)
  private
    FList: TList;  // main list with all resource pointers
    FMergeList: TList; // list needed for mergesort
    FSortedCount: integer; // 0 .. FSortedCount-1 resources are sorted
    function FindPosition(const Name: AnsiString):integer;
    function GetItems(Index: integer): TfpgResource;
    procedure Sort;
    procedure MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
    procedure Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
  public
    constructor Create;
    destructor Destroy;  override;
    procedure Add(const Name, ValueType, Value: AnsiString);
    procedure Add(const Name, ValueType: AnsiString; const Values: array of string);
    function Find(const Name: AnsiString): TfpgResource; overload;
    function Find(const Name, ValueType: AnsiString): TfpgResource; overload;
    function Count: integer;
    property Items[Index: integer]: TfpgResource read GetItems;
  end;

var
  LazarusResources: TfpgResourceList;

implementation

{ TfpgResourceList }

function TfpgResourceList.FindPosition(const Name: AnsiString): integer;
var
  L, R, C: Integer;
begin
  if FSortedCount < FList.Count then
    Sort;
  L := 0;
  R := FList.Count-1;
  while (L <= R) do
  begin
    Result := (L + R) shr 1;
    C := AnsiCompareText(Name, TfpgResource(FList[Result]).Name);
    if C < 0 then
      R := Result - 1
    else
    if C > 0 then
      L := Result + 1
    else
      Exit;
  end;
  Result := -1;
end;

function TfpgResourceList.GetItems(Index: integer): TfpgResource;
begin
  Result := TfpgResource(FList[Index]);
end;

procedure TfpgResourceList.Sort;
{$IFNDEF DisableChecks}
var
  i: Integer;
  r1: TfpgResource;
  r2: TfpgResource;
{$ENDIF}
begin
  if FSortedCount = FList.Count then
    exit;
  // sort the unsorted elements
  FMergeList.Count := FList.Count;
  MergeSort(FList, FMergeList, FSortedCount, FList.Count - 1);
  // merge both
  Merge(FList, FMergeList, 0, FSortedCount, FList.Count - 1);
  FSortedCount := FList.Count;
  // check for doubles
  {$IFNDEF DisableChecks}
  for i:=0 to FList.Count-2 do
  begin
    r1:=TfpgResource(FList[i]);
    r2:=TfpgResource(FList[i+1]);
    if (AnsiCompareText(r1.Name,r2.Name)=0) and (r1.ValueType=r2.ValueType) then
      writeln('TLResourceList.Sort ',i,' DUPLICATE RESOURCE FOUND: ',r1.Name,':',r1.ValueType);
  end;
  {$ENDIF}
end;

procedure TfpgResourceList.MergeSort(List, MergeList: TList; Pos1, Pos2: integer
  );
var
  cmp, mid: integer;
begin
  if Pos1 = Pos2 then
  begin
  end else
  if Pos1 + 1 = Pos2 then
  begin
    cmp := AnsiCompareText(TfpgResource(List[Pos1]).Name, TfpgResource(List[Pos2]).Name);
    if cmp > 0 then
    begin
      MergeList[Pos1] := List[Pos1];
      List[Pos1] := List[Pos2];
      List[Pos2] := MergeList[Pos1];
    end;
  end else
  begin
    if Pos2 > Pos1 then
    begin
      mid := (Pos1 + Pos2) shr 1;
      MergeSort(List, MergeList, Pos1, mid);
      MergeSort(List, MergeList, mid + 1, Pos2);
      Merge(List, MergeList, Pos1, mid + 1, Pos2);
    end;
  end;
end;

procedure TfpgResourceList.Merge(List, MergeList: TList; Pos1, Pos2,
  Pos3: integer);
// merge two sorted arrays
// the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
var
  Src1Pos, Src2Pos, DestPos, cmp, a: integer;
begin
  if (Pos1 >= Pos2) or (Pos2 > Pos3) then
    exit;
  Src1Pos := Pos2 - 1;
  Src2Pos := Pos3;
  DestPos := Pos3;
  while (Src2Pos >= Pos2) and (Src1Pos >= Pos1) do
  begin
    cmp:=AnsiCompareText(TfpgResource(List[Src1Pos]).Name, TfpgResource(List[Src2Pos]).Name);
    if cmp > 0 then
    begin
      MergeList[DestPos] := List[Src1Pos];
      dec(Src1Pos);
    end else
    begin
      MergeList[DestPos] := List[Src2Pos];
      dec(Src2Pos);
    end;
    dec(DestPos);
  end;
  while Src2Pos >= Pos2 do
  begin
    MergeList[DestPos] := List[Src2Pos];
    dec(Src2Pos);
    dec(DestPos);
  end;
  for a := DestPos + 1 to Pos3 do
    List[a] := MergeList[a];
end;

constructor TfpgResourceList.Create;
begin
  FList := TList.Create;
  FMergeList := TList.Create;
  FSortedCount := 0;
end;

destructor TfpgResourceList.Destroy;
var
  a: Integer;
begin
  for a := 0 to FList.Count - 1 do
    TfpgResource(FList[a]).Free;
  FList.Free;
  FMergeList.Free;
  inherited Destroy;
end;

procedure TfpgResourceList.Add(const Name, ValueType, Value: AnsiString);
begin
  Add(Name, ValueType, [Value]);
end;

procedure TfpgResourceList.Add(const Name, ValueType: AnsiString;
  const Values: array of string);
var
  NewResource: TfpgResource;
  i, TotalLen, ValueCount, p: integer;
begin
  NewResource := TfpgResource.Create;
  NewResource.Name := Name;
  NewResource.ValueType := uppercase(ValueType);

  ValueCount := High(Values) - Low(Values) + 1;
  case ValueCount of
    0:
      begin
        NewResource.Free;
        exit;
      end;
    1:
      NewResource.Value:=Values[0];
  else
    TotalLen := 0;
    for i := Low(Values) to High(Values) do
      inc(TotalLen, length(Values[i]));
    SetLength(NewResource.Value, TotalLen);
    p := 1;
    for i := Low(Values) to High(Values) do
    begin
      if length(Values[i]) > 0 then
      begin
        Move(Values[i][1], NewResource.Value[p], length(Values[i]));
        inc(p, length(Values[i]));
      end;
    end;
  end;

  FList.Add(NewResource);
end;

function TfpgResourceList.Find(const Name: AnsiString): TfpgResource;
var
  P: Integer;
begin
  P := FindPosition(Name);
  if P >= 0 then
    Result := TfpgResource(FList[P])
  else
    Result := nil;
end;

function TfpgResourceList.Find(const Name, ValueType: AnsiString
  ): TfpgResource;
var
  P, I: Integer;
begin
  P := FindPosition(Name);
  if P >= 0 then
  begin
    // Since we can have many resources that have the same name but different type
    // we should look before and after found position (do not forget that we are searching
    // them by dividing intervals)

    // look before position
    for I := P - 1 downto 0 do
    begin
      Result := TfpgResource(FList[I]);
      if AnsiCompareText(Result.Name,Name)<>0 then
        break;
      if Result.ValueType = ValueType then
        Exit;
    end;
    // look behind position
    for I := P to FList.Count - 1 do
    begin
      Result := TfpgResource(FList[I]);
      if AnsiCompareText(Result.Name,Name)<>0 then
        break;
      if Result.ValueType = ValueType then
        Exit;
    end;
  end;
  Result := nil;
end;

function TfpgResourceList.Count: integer;
begin
  if (Self<>nil) and (FList<>nil) then
    Result:=FList.Count
  else
    Result:=0;
end;

//------------------------------------------------------------------------------
procedure InternalInit;
begin
  LazarusResources := TfpgResourceList.Create;
end;

initialization
  InternalInit;

finalization
  FreeAndNil(LazarusResources);


end.

